PC Media 2/PC MEDIA CD02.iso/share/prog/tpsorts/sortdemo.pas

Pascal/Delphi Source File | 1985-10-04 | 12.4 KB | 509 lines

Program SortDemo;

{**************************************************************************
*                                                                         *
* Description:                                                            *
*                                                                         *
*   This program graphically displays the functioning of 8 of the most    *
*   common sorting algorithms in use today.                               *
*                                                                         *
*                                                                         *
* Author:  Richard R. Rebouche                                            *
*                                                                         *
* Update:  05/15/85                                                       *
*                                                                         *
*                                                                         *
* Comments:                                                               *
*                                                                         *
*   This program was written to kill an afternoon in celebration of       *
*   the end of finals.                                                    *
*                                                                         *
*   I would encourage anyone interested in the topic of sorting to        *
*   refer to Chap. 7 of Wirth's book `Algorithms + Data Structures'.      *
*   This book served as the reference for the more complex algorithms     *
*   presented here, such as the Quick Sort.                               *
*                                                                         *
*   I would like to know if anyone makes enhancements or extensions to    *
*   this program, so please upload any improvements.                      *
*                                                                         *
*                                                                         *
* BBS:                                                                    *
*                                                                         *
*   This source code will originate from John Friel's BBS in Cedar Falls, *
*   IA.  PH: [phone]                                               *
*                                                                         *
**************************************************************************}


Const NumItems = 200;

Type Sort_Array_Type = Array [0..NumItems] of Integer;

   { Note: Must start at zero because of insertion sort }
   {       All other sorts consider the arrays to begin }
   {       at base one.                                 }


Var I, J     : Integer;
    OrgArray : Sort_Array_Type;
    NumArray : Sort_Array_Type;
    Done     : Boolean;
    C        : Char;





{ Interchange two integers, erasing and redrawing them on the screen }

Procedure Exchange (Y1, Y2 : Integer;  Var X1, X2 : Integer);

Var X3 : Integer;

Begin
  Plot (X1, Y1-1, 0);     { Erase old points   }
  Plot (X2, Y2-1, 0);
  X3 := X1;               { Interchange values }
  X1 := X2;
  X2 := X3;
  Plot (X1, Y1-1, 1);     { Draw new points    }
  Plot (X2, Y2-1, 1);
End;




{ Assign a new value to an integer, erasing and redrawing it }

Procedure AssignValue (Y : Integer;  Var X: Integer;  N : Integer);

Begin
  Plot (X, Y-1, 0);     { Erase old point  }
  X := N;               { Assign new value }
  Plot (X, Y-1, 1);     { Draw new point   }
End;




{ Prompt the user to press the SPACEBAR }

Procedure Done_Prompt;

Var C : Char;

Begin
  GotoXY (1, 24);
  Write ('Press the SPACEBAR to continue . . .');
  C := Chr(0);
  While C <> ' ' Do
    Read (Kbd, C);
End;




{ Fill an array with random numbers between 0 and 639, inclusive }

Procedure Fill_Array (Var A : Sort_Array_Type);

Var I : Integer;

Begin
  For I := 1 to NumItems do
    A[I] := Random(640);
End;




{ Print the contents of an array }

Procedure PrintArray (Var A : Sort_Array_Type);

Var I, N : Integer;

Begin
  Writeln;
  For I := 1 to NumItems do
    Begin
      Write (A[i]:4);
      If WhereX > 75 Then
        Writeln;
    End;
  Writeln;
End;




{ Plot the contents of an array onto the graphics screen }

Procedure PlotArray (Var A : Sort_Array_Type);

Var I, J, N : Integer;
    C       : Char;

Begin
  Hires;
  Hirescolor (white);
  For I := 1 to NumItems do
    Plot (A[I], I-1, 1);
End;




{ Sort an array using the `Bubble' algorithm }

Procedure BubbleSort (Var A : Sort_Array_Type);

Var I, J, N : Integer;

Begin
  For I := 2 to NumItems do
    For J := NumItems DownTo I do
      If A[J-1] > A[J] Then
        Exchange (J-1, J, A[J-1], A[J]);
End;




{ Sort an array using the `Shaker' (bi-directional bubble) algorithm }

Procedure ShakerSort (Var A : Sort_Array_Type);

Var J, K, L, R : Integer;
    X          : Integer;

Begin
  L := 1; R := NumItems; K := NumItems;
  Repeat
    For J := R DownTo L do
      If A[J-1] > A[J] then
        Begin
          Exchange (J-1, J, A[J-1], A[J]);
          K := J;
        End;
    L := K + 1;
    For J := L To R do
      If A[J-1] > A[J] then
        Begin
          Exchange (J-1, J, A[J-1], A[J]);
          K := J;
        End;
    R := K-1;
  Until L > R;
End;





{ Sort an array using the `Insertion' algorithm }

Procedure InsertionSort (Var A : Sort_Array_Type);

Var I,J, X : Integer;

Begin
  For I := 2 to NumItems do
    Begin
      X := A[I];  A[0] := X;  J := I-1;
      While X < A[J] do
        Begin
          AssignValue (J+1, A[J+1], A[J]);  J := J - 1;
        End;
      AssignValue(J+1, A[J+1], X);
    End;
End;




{ Sort an array using the `Binary Insertion' algorithm }

Procedure BinaryInsertionSort (Var A : Sort_Array_Type);

Var I,J,L,R,M,X : Integer;

Begin
  For I := 2 to NumItems do
    Begin
      X := A[I];  L := 1;  R := I-1;
      While L <= R do
        Begin
          M := (L+R) Div 2;
          If X < A[M] Then
            R := M - 1
          Else L := M+1
        End;
      For J := I-1 DownTo L do
        AssignValue (J+1, A[J+1], A[J]);
      AssignValue (L, A[L], X);
    End;
End;




{ Sort an array using the `Selection' algorithm }

Procedure SelectionSort (Var A : Sort_Array_Type);

Var I, J, K, X : Integer;

Begin
  For I := 1 to NumItems - 1 do
    Begin
      K := I;  X := A[I];
      For J := I+1 To NumItems do
        If A[J] < X then
          Begin
            K := J;  X := A[J];
          End;
      AssignValue (K, A[K], A[I]);
      AssignValue (I, A[I], X);
    End;
End;





{ Sort an array using the `Shell' algorithm (6 parts, binary progression) }

Procedure ShellSort (Var A : Sort_Array_Type);

  Const T = 6;
        H : Array [1..T] Of Integer = (33,17,9,5,3,1);

  Var I,J,K,S, M, X : Integer;

Begin
  For M := 1 To T Do
    Begin
      K := H[M];  S := -K; {sentinal position}
      For I := K+1 To NumItems do
        Begin
          X := A[I]; J := I-K;
          If S = 0 Then
            S := -K; S:= S+1; AssignValue(S, A[S], X);
          While X < A[J] do
            Begin
              AssignValue (J+K, A[J+K], A[J]);
              J := J - K;
            End;
          AssignValue (J+K, A[J+K], X);
        End;
    End;
End;





{ Sort an array using the `Heap' algorithm }

Procedure HeapSort (Var A : Sort_Array_Type);
Var L,R,X : Integer;

  Procedure Sift;
    Label 13;
    Var I,J : integer;
  Begin
    I := L;  J := 2 *I;  X := A[I];
    While J <= R do
      Begin
        If J < R Then
          If A[J] < A[J+1] Then
            J := J + 1;
        If X >= A[J] Then
          GoTo 13;
        AssignValue(I, A[I], A[J]);  I := J;  J := 2 * I;
      End;
    13:AssignValue(I, A[I], X);
  End;

Begin
  L := (NumItems Div 2) + 1;  R:= NumItems;
  While L > 1 do
    Begin
      L := L-1; Sift;
    End;
  While r > 1 do
    Begin
      Exchange (1, R, A[1], A[R]);
      R := R - 1;
      Sift;
    End;
End;




{ Sort an array using the `Quick' algorithm (recursive form) }

procedure quicksort (Var A : Sort_Array_Type);

  Procedure Sort (L, R : Integer);
    Var I, J, X : Integer;
  Begin
    I := L;  J := R;
    X := A[(L+R) Div 2];
    Repeat
      While A[I] < X do
        I := I + 1;
      While X < A[J] do
        J := J - 1;
      If I <= J then
      Begin
        Exchange (I, J, A[I], A[J]);
        I := I + 1;  J := J - 1;
      End;
    Until I > J;
    If L < J Then
      Sort (L, J);
    If I < R Then
      Sort (I, R);
  End;

Begin
  Sort (1, NumItems);
End;





{ Display the opening screen }

procedure Do_Title_Screen;

Var I, J : Integer;

Begin
  ClrScr;
  GotoXY (28, 1);  Write ('************************');
  GotoXY (28, 2);  Write ('*                      *');
  GotoXY (28, 3);  Write ('*  Sort Demonstration  *');
  GotoXY (28, 4);  Write ('*                      *');
  GotoXY (28, 5);  Write ('*   Update: 05/15/85   *');
  GotoXY (28, 6);  Write ('*                      *');
  GotoXY (28, 7);  Write ('************************');
  Window (9, 1, 80, 25);
  GotoXY (1, 10);
  WriteLn ('This program illustrates eight of the most common array-sorting');
  WriteLn ('algorithms in use today.');
  WriteLn;
  WriteLn ('The sorts are applied to a 200 element array containing integer');
  writeLn ('values ranging from 0 to 639, inclusive.');
  WriteLn;
  WriteLn ('Subscripts start at the top of the screen and work down.');
  WriteLn;
  WriteLn ('Numeric values start at the left of the screen and work right.');
  WriteLn;
  WriteLn;
  WriteLn ('               Enjoy!   -   Richard R. Rebouche');
  Window (1, 1, 80, 25);
  Done_Prompt;
End;



{ Display the program menu, return the selection }

Function Get_Choice : Char;

Var I, J : Integer;
    C    : Char;

Begin
  Textmode;
  ClrScr;
  GotoXY (25,3);   WriteLn ('******************************');
  GotoXY (25,4);   WriteLn ('*                            *');
  GotoXY (25,5);   WriteLn ('* Sort Demonstration Program *');
  GotoXY (25,6);   WriteLn ('*                            *');
  GotoXY (25,7);   WriteLn ('******************************');
  WriteLn;
  WriteLn;
  WriteLn ('1 - ':29,  'Bubble Sort');
  WriteLn ('2 - ':29,  'Shaker Sort');
  WriteLn ('3 - ':29,  'Straight Insertion Sort');
  WriteLn ('4 - ':29,  'Binary Insertion Sort');
  WriteLn ('5 - ':29,  'Selection Sort');
  WriteLn ('6 - ':29,  'Shell Sort');
  WriteLn ('7 - ':29,  'Heap Sort');
  WriteLn ('8 - ':29,  'Quick Sort');
  WriteLn ('V - ':29,  'View Current Data Set');
  WriteLn ('G - ':29,  'Generate New Data Set');
  WriteLn ('Q - ':29,  'Terminate Demonstration');
  WriteLn;
  WriteLn;
  C := ' ';
  Write ('Selection: ':43);
  While Not (C In ['1'..'8', 'V', 'G', 'Q']) do
    Begin
      Read (Kbd, C);
      C := UpCase (C);
    End;
  Writeln (C);
  Get_Choice := C;
End;




{ Set up and call the sort procedures based upon 'N' }

Procedure PerformSort (N : Integer);
Begin
  NumArray := OrgArray;
  PlotArray (NumArray);
  Case N of
    1 : BubbleSort (NumArray);
    2 : ShakerSort (NumArray);
    3 : InsertionSort (NumArray);
    4 : BinaryInsertionSort (NumArray);
    5 : SelectionSort (NumArray);
    6 : ShellSort (NumArray);
    7 : HeapSort (NumArray);
    8 : QuickSort (NumArray);
  End;
  Done_Prompt;
End;



Begin
  Fill_Array (OrgArray);
  Done := false;
  Do_Title_Screen;
  While Not Done do
    Begin
      C := Get_Choice;
      ClrScr;
      If C In ['1'..'8'] then
        PerformSort (Ord(C) - Ord('0'))
      Else
        Case C of
          'V' : Begin
                  WriteLn ('Current Data Collection:');
                  GotoXY (1, WhereY + 5);
                  PrintArray (OrgArray);
                  Done_Prompt;
                End;
          'G' : Begin
                  WriteLn ('Generating New Data Collection:');
                  Fill_Array (OrgArray);
                  GotoXY (1, WhereY + 5);
                  PrintArray (OrgArray);
                  Done_Prompt;
                End;
          'Q' : Done := True;
       End; {Case}
    End; {While}
End.